home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / scrt2.sc < prev    next >
Text File  |  1991-10-11  |  18KB  |  617 lines
  1. ;;; SCHEME->C Runtime Library
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. (module scrt2
  42.     (top-level
  43.     SYMBOL? SYMBOL->STRING TOP-LEVEL-VALUE SET-TOP-LEVEL-VALUE!
  44.     GETPROP PUTPROP
  45.     FIXED? FLOAT? FLOAT->FIXED FIXED->FLOAT
  46.     NUMBER? COMPLEX? REAL? RATIONAL? INTEGER? ZERO?    POSITIVE? NEGATIVE?
  47.     ODD? EVEN? EXACT? INEXACT? = < > <= >= MAX MIN + * - / ABS QUOTIENT
  48.     REMAINDER MODULO GCD LCM FLOOR CEILING TRUNCATE ROUND
  49.     EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT
  50.     EXACT->INEXACT INEXACT->EXACT
  51.     NUMBER->STRING STRING->NUMBER))
  52.  
  53. ;;; 6.4  Symbols.
  54.  
  55. (define (SYMBOL? x) (symbol? x))
  56.  
  57. (define (SYMBOL->STRING x) (symbol->string x))
  58.  
  59. (define (TOP-LEVEL-VALUE symbol)
  60.     (if (not (symbol? symbol))
  61.     (error 'TOP-LEVEL-VALUE "Argument is not a SYMBOL: ~s" symbol))
  62.     ((lap (symbol) (SYMBOL_VALUE symbol)) symbol))
  63.  
  64. (define (SET-TOP-LEVEL-VALUE! symbol value)
  65.     (if (not (symbol? symbol))
  66.     (error 'SET-TOP-LEVEL-VALUE! "Argument is not a SYMBOL: ~s" symbol))
  67.     ((lap (symbol value) (SETGENTL (SYMBOL_VALUE symbol) value)) symbol value))
  68.  
  69. (define (GETPROP symbol key)
  70.     (if (not (symbol? symbol))
  71.     (error 'GETPROP "Argument is not a SYMBOL: ~s" symbol))
  72.     (let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol)))
  73.      (cond ((null? pl) #f)
  74.            ((eq? (car pl) key) (cadr pl))
  75.            (else (loop (cddr pl))))))
  76.  
  77. (define (PUTPROP symbol key value)
  78.     (if (not (symbol? symbol))
  79.     (error 'PUTPROP "Argument is not a SYMBOL: ~s" symbol))
  80.     (let loop ((pl ((lap (symbol) (SYMBOL_PROPERTYLIST symbol)) symbol))
  81.            (prev '()))
  82.      (cond ((null? pl)
  83.         (if (not (eq? value #f))
  84.             (if prev
  85.             (set-cdr! prev (list key value))
  86.             ((lap (symbol newpl)
  87.                   (SETGEN (SYMBOL_PROPERTYLIST symbol) newpl))
  88.              symbol (list key value)))))
  89.            ((eq? (car pl) key)
  90.         (if (eq? value #f)
  91.             (if prev
  92.             (set-cdr! prev (cddr pl))
  93.             ((lap (symbol newpl)
  94.                   (SETGEN (SYMBOL_PROPERTYLIST symbol) newpl))
  95.              symbol (cddr pl)))
  96.             (set-car! (cdr pl) value)))
  97.            (else (loop (cddr pl) (cdr pl)))))
  98.     value)
  99.  
  100. ;;; 6.5  Numbers.
  101.  
  102. ;;; Arithmetic overflow traps possibly enabled here.
  103.  
  104. (define-external (MATHTRAPS) "sc" "mathtraps")
  105.  
  106. (mathtraps)
  107.  
  108. (define (FIXED? x) (fixed? x))
  109.  
  110. (define (FLOAT? x) (float? x))
  111.  
  112. (define (FLOAT->FIXED x) (float->fixed x))
  113.  
  114. (define (FIXED->FLOAT x) (fixed->float x))
  115.  
  116. (define (NUMBER? x) (or (fixed? x) (float? x)))
  117.  
  118. (define (COMPLEX? x) (or (fixed? x) (float? x)))
  119.  
  120. (define (REAL? x) (or (fixed? x) (float? x)))
  121.  
  122. (define (RATIONAL? x) (fixed? x))
  123.  
  124. (define (INTEGER? x) (fixed? x))
  125.  
  126. (define (ZERO? x) (= x 0))
  127.  
  128. (define (POSITIVE? x) (> x 0))
  129.  
  130. (define (NEGATIVE? x) (< x 0))
  131.  
  132. (define (ODD? x) (odd? x))
  133.  
  134. (define (EVEN? x) (even? x))
  135.  
  136. (define (EXACT? x) (exact? x))
  137.  
  138. (define (INEXACT? x) (inexact? x))
  139.  
  140. (define (=-TWO x y)
  141.     (cond ((fixed? x)
  142.        (cond ((fixed? y)
  143.           ((lap (x y) (BOOLEAN (EQ (INT x) (INT y)))) x y))
  144.          ((float? y)
  145.           ((lap (x y) (BOOLEAN (EQ (FIX_FLTV x) (FLOAT_VALUE y))))
  146.            x y))
  147.          (else (error '= "Argument not a NUMBER: ~s" y))))
  148.       ((fixed? y)
  149.        (cond ((float? x)
  150.           ((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FIX_FLTV y))))
  151.            x y))
  152.          (else (error '= "Argument not a NUMBER: ~s" x))))
  153.       ((and (float? x) (float? y))
  154.        ((lap (x y) (BOOLEAN (EQ (FLOAT_VALUE x) (FLOAT_VALUE y))))
  155.         x y))
  156.       (else (error '= "Argument(s) not a NUMBER: ~s ~s" x y))))      
  157.  
  158. (define (= x y . z)
  159.     (define (=-LIST x z)
  160.         (cond ((null? z) #t)
  161.           ((= x (car z)) (=-list (car z) (cdr z)))
  162.           (else #f)))
  163.     (and (= x y) (=-list y z)))
  164.  
  165. (define (<-TWO x y)
  166.     (cond ((fixed? x)
  167.        (cond ((fixed? y)
  168.           ((lap (x y) (BOOLEAN (LT (INT x) (INT y)))) x y))
  169.          ((float? y)
  170.           ((lap (x y) (BOOLEAN (LT (FIX_FLTV x) (FLOAT_VALUE y))))
  171.            x y))
  172.          (else (error '< "Argument not a NUMBER: ~s" y))))
  173.       ((fixed? y)
  174.        (cond ((float? x)
  175.           ((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FIX_FLTV y))))
  176.            x y))
  177.          (else (error '< "Argument not a NUMBER: ~s" x))))
  178.       ((and (float? x) (float? y))
  179.        ((lap (x y) (BOOLEAN (LT (FLOAT_VALUE x) (FLOAT_VALUE y))))
  180.         x y))
  181.       (else (error '< "Argument(s) not a NUMBER: ~s ~s" x y))))      
  182.  
  183. (define (< x y . z)
  184.     (define (<-LIST x z)
  185.         (cond ((null? z) #t)
  186.           ((< x (car z)) (<-list (car z) (cdr z)))
  187.           (else #f)))
  188.     (and (< x y) (<-list y z)))
  189.  
  190. (define (>-TWO x y)
  191.     (cond ((fixed? x)
  192.        (cond ((fixed? y)
  193.           ((lap (x y) (BOOLEAN (GT (INT x) (INT y)))) x y))
  194.          ((float? y)
  195.           ((lap (x y) (BOOLEAN (GT (FIX_FLTV x) (FLOAT_VALUE y))))
  196.            x y))
  197.          (else (error '> "Argument not a NUMBER: ~s" y))))
  198.       ((fixed? y)
  199.        (cond ((float? x)
  200.           ((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FIX_FLTV y))))
  201.            x y))
  202.          (else (error '> "Argument not a NUMBER: ~s" x))))
  203.       ((and (float? x) (float? y))
  204.        ((lap (x y) (BOOLEAN (GT (FLOAT_VALUE x) (FLOAT_VALUE y))))
  205.         x y))
  206.       (else (error '> "Argument(s) not a NUMBER: ~s ~s" x y))))      
  207.  
  208. (define (> x y . z)
  209.     (define (>-LIST x z)
  210.         (cond ((null? z) #t)
  211.           ((> x (car z)) (>-list (car z) (cdr z)))
  212.           (else #f)))
  213.     (and (> x y) (>-list y z)))
  214.  
  215. (define (<=-TWO x y)
  216.     (cond ((fixed? x)
  217.        (cond ((fixed? y)
  218.           ((lap (x y) (BOOLEAN (LTE (INT x) (INT y)))) x y))
  219.          ((float? y)
  220.           ((lap (x y) (BOOLEAN (LTE (FIX_FLTV x) (FLOAT_VALUE y))))
  221.            x y))
  222.          (else (error '<= "Argument not a NUMBER: ~s" y))))
  223.       ((fixed? y)
  224.        (cond ((float? x)
  225.           ((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FIX_FLTV y))))
  226.            x y))
  227.          (else (error '<= "Argument not a NUMBER: ~s" x))))
  228.       ((and (float? x) (float? y))
  229.        ((lap (x y) (BOOLEAN (LTE (FLOAT_VALUE x) (FLOAT_VALUE y))))
  230.         x y))
  231.       (else (error '<= "Argument(s) not a NUMBER: ~s ~s" x y))))      
  232.  
  233. (define (<= x y . z)
  234.     (define (<=-LIST x z)
  235.         (cond ((null? z) #t)
  236.           ((<= x (car z)) (<=-list (car z) (cdr z)))
  237.           (else #f)))
  238.     (and (<= x y) (<=-list y z)))
  239.  
  240. (define (>=-TWO x y)
  241.     (cond ((fixed? x)
  242.        (cond ((fixed? y)
  243.           ((lap (x y) (BOOLEAN (GTE (INT x) (INT y)))) x y))
  244.          ((float? y)
  245.           ((lap (x y) (BOOLEAN (GTE (FIX_FLTV x) (FLOAT_VALUE y))))
  246.            x y))
  247.          (else (error '>= "Argument not a NUMBER: ~s" y))))
  248.       ((fixed? y)
  249.        (cond ((float? x)
  250.           ((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FIX_FLTV y))))
  251.            x y))
  252.          (else (error '>= "Argument not a NUMBER: ~s" x))))
  253.       ((and (float? x) (float? y))
  254.        ((lap (x y) (BOOLEAN (GTE (FLOAT_VALUE x) (FLOAT_VALUE y))))
  255.         x y))
  256.       (else (error '>= "Argument(s) not a NUMBER: ~s ~s" x y))))
  257.  
  258. (define (>= x y . z)
  259.     (define (>=-LIST x z)
  260.         (cond ((null? z) #t)
  261.           ((>= x (car z)) (>=-list (car z) (cdr z)))
  262.           (else #f)))
  263.     (and (>= x y) (>=-list y z)))
  264.       
  265. (define (MAX-TWO x y) (if (> x y) x y))
  266.  
  267. (define (MAX x . y)
  268.     (let loop ((x x) (y y))
  269.      (if y
  270.          (loop (if (> x (car y)) x (car y)) (cdr y))
  271.          x)))
  272.  
  273. (define (MIN-TWO x y) (if (< x y) x y))
  274.  
  275. (define (MIN x . y)
  276.     (let loop ((x x) (y y))
  277.      (if y
  278.          (loop (if (< x (car y)) x (car y)) (cdr y))
  279.          x)))
  280.  
  281. (define (+-TWO x y)
  282.     (cond ((fixed? x)
  283.        (cond ((fixed? y)
  284.           ((lap (x y) (_TSCP (IPLUS (INT x) (INT y)))) x y))
  285.          ((float? y)
  286.           ((lap (x y) (FLTV_FLT (PLUS (FIX_FLTV x) (FLOAT_VALUE y))))
  287.            x y))
  288.          (else (error '+ "Argument not a NUMBER: ~s" y))))
  289.       ((fixed? y)
  290.        (cond ((float? x)
  291.           ((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FIX_FLTV y))))
  292.            x y))
  293.          (else (error '+ "Argument not a NUMBER: ~s" x))))
  294.       ((and (float? x) (float? y))
  295.        ((lap (x y) (FLTV_FLT (PLUS (FLOAT_VALUE x) (FLOAT_VALUE y))))
  296.         x y))
  297.       (else (error '+ "Argument(s) not a NUMBER: ~s ~s" x y))))
  298.  
  299. (define (+ . x)
  300.     (let loop ((sum 0) (x x))
  301.      (if x
  302.          (loop (+ sum (car x)) (cdr x))
  303.          sum)))
  304.  
  305. (define (*-TWO x y)
  306.     (cond ((fixed? x)
  307.        (cond ((fixed? y)
  308.           ((lap (x y) (_TSCP (ITIMES (FIXED_C x) (INT y)))) x y))
  309.          ((float? y)
  310.           ((lap (x y)
  311.             (FLTV_FLT (TIMES (FIX_FLTV x) (FLOAT_VALUE y))))
  312.            x y))
  313.          (else (error '* "Argument not a NUMBER: ~s" y))))
  314.       ((fixed? y)
  315.        (cond ((float? x)
  316.           ((lap (x y)
  317.             (FLTV_FLT (TIMES (FLOAT_VALUE x) (FIX_FLTV y))))
  318.            x y))
  319.          (else (error '* "Argument not a NUMBER: ~s" x))))
  320.       ((and (float? x) (float? y))
  321.        ((lap (x y) (FLTV_FLT (TIMES (FLOAT_VALUE x) (FLOAT_VALUE y))))
  322.         x y))
  323.       (else (error '* "Argument(s) not a NUMBER: ~s ~s" x y))))
  324.  
  325. (define (* . x)
  326.     (let loop ((product 1) (x x))
  327.      (if x
  328.          (loop (* product (car x)) (cdr x))
  329.          product)))
  330.  
  331. (define (--TWO x y)
  332.     (cond ((fixed? x)
  333.        (cond ((fixed? y)
  334.           ((lap (x y) (_TSCP (IDIFFERENCE (INT x) (INT y)))) x y))
  335.          ((float? y)
  336.           ((lap (x y)
  337.             (FLTV_FLT (DIFFERENCE (FIX_FLTV x) (FLOAT_VALUE y))))
  338.            x y))
  339.          (else (error '- "Argument not a NUMBER: ~s" y))))
  340.       ((fixed? y)
  341.        (cond ((float? x)
  342.           ((lap (x y)
  343.             (FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FIX_FLTV y))))
  344.            x y))
  345.          (else (error '- "Argument not a NUMBER: ~s" x))))
  346.       ((and (float? x) (float? y))
  347.        ((lap (x y)
  348.          (FLTV_FLT (DIFFERENCE (FLOAT_VALUE x) (FLOAT_VALUE y))))
  349.         x y))
  350.       (else (error '- "Argument(s) not a NUMBER: ~s ~s" x y))))
  351.  
  352. (define (- x . y)
  353.     (if y
  354.     (let loop ((result (- x (car y))) (args (cdr y)))
  355.          (if args
  356.          (loop (- result (car args)) (cdr args))
  357.          result))
  358.     (- 0 x)))
  359.  
  360. (define (/-TWO x y)
  361.     (cond ((fixed? x)
  362.        (cond ((fixed? y)
  363.           (if (eq? ((lap (x y) (_TSCP (REMAINDER (INT x) (INT y))))
  364.                  x y)
  365.                0)
  366.               ((lap (x y) (C_FIXED (QUOTIENT (INT x) (INT y)))) x y)
  367.               ((lap (x y) (FLTV_FLT (QUOTIENT (FIX_FLTV x)
  368.                         (FIX_FLTV y))))
  369.                x y)))
  370.          ((float? y)
  371.           ((lap (x y)
  372.             (FLTV_FLT (QUOTIENT (FIX_FLTV x) (FLOAT_VALUE y))))
  373.            x y))
  374.          (else (error '/ "Argument not a NUMBER: ~s" y))))
  375.       ((fixed? y)
  376.        (cond ((float? x)
  377.           ((lap (x y)
  378.             (FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FIX_FLTV y))))
  379.            x y))
  380.          (else (error '/ "Argument not a NUMBER: ~s" x))))
  381.       ((and (float? x) (float? y))
  382.        ((lap (x y)
  383.          (FLTV_FLT (QUOTIENT (FLOAT_VALUE x) (FLOAT_VALUE y))))
  384.         x y))
  385.       (else (error '/ "Argument(s) not a NUMBER: ~s ~s" x y))))
  386.  
  387. (define (/ x . y)
  388.     (if y
  389.     (let loop ((result (/ x (car y))) (z (cdr y)))
  390.          (if z
  391.          (loop (/ result (car z)) (cdr z))
  392.          result))
  393.     (/ 1 x)))
  394.  
  395. (define (ABS x) (if (negative? x) (- 0 x) x))
  396.  
  397. (define (QUOTIENT x y)
  398.     (if (two-fixeds? x y)
  399.     ((lap (x y) (C_FIXED (QUOTIENT (INT x) (INT y)))) x y)
  400.     (truncate (/ x y))))
  401.  
  402. (define (REMAINDER x y)
  403.     (if (two-fixeds? x y)
  404.     ((lap (x y) (_TSCP (REMAINDER (INT x) (INT y)))) x y)
  405.     (round (- x (* y (quotient x y))))))
  406.  
  407. (define (MODULO x y)
  408.     (let ((r (remainder x y)))
  409.      (if (zero? r)
  410.          r        
  411.          (if (positive? y)
  412.          (if (positive? r) r (+ y r))
  413.          (if (negative? r) r (+ y r))))))
  414.  
  415. (define (GCD . x)
  416.     (define (GCD2 m n)
  417.         (let ((r (remainder m n)))
  418.          (if (= r 0) n (gcd2 n r))))
  419.     (case (length x)
  420.       ((0) 0)
  421.       ((1) (abs (car x)))
  422.       (else (let loop ((result (gcd2 (abs (car x)) (abs (cadr x))))
  423.                (left (cddr x)))
  424.              (if left
  425.              (loop (gcd2 result (abs (car left))) (cdr left))
  426.              result)))))
  427.  
  428. (define (LCM . x)
  429.     (define (LCM2 m n)
  430.         (let ((m (abs m)) (n (abs n)))
  431.          (cond ((= m n) m)
  432.                ((= (remainder m n) 0) m)
  433.                ((= (remainder n m) 0) n)
  434.                (else (* (/ m (gcd m n)) n)))))
  435.     (case (length x)
  436.       ((0) 1)
  437.       ((1) (abs (car x)))
  438.       (else (let loop ((result (lcm2 (car x) (cadr x))) (left (cddr x)))
  439.              (if left
  440.              (loop (lcm2 result (car left)) (cdr left))
  441.              result)))))
  442.  
  443. (define-c-external (c-floor double) double "floor")
  444.  
  445. (define (FLOOR x) (if (fixed? x) x (c-floor x)))
  446.  
  447. (define-c-external (c-ceiling double) double "ceil")
  448.  
  449. (define (CEILING x) (if (fixed? x) x (c-ceiling x)))
  450.  
  451. (define-c-external (c-exp double) double "exp")
  452.  
  453. (define (TRUNCATE x) (if (< x 0) (ceiling x) (floor x)))
  454.  
  455. (define (ROUND x) (if (fixed? x) x (floor (+ x .5))))
  456.  
  457. (define (EXP x) (c-exp x))
  458.  
  459. (define-c-external (c-log double) double "log")
  460.  
  461. (define (LOG x) (c-log x))
  462.  
  463. (define-c-external (c-sin double) double "sin")
  464.  
  465. (define (SIN x) (c-sin x))
  466.  
  467. (define-c-external (c-cos double) double "cos")
  468.  
  469. (define (COS x) (c-cos x))
  470.  
  471. (define-c-external (c-tan double) double "tan")
  472.  
  473. (define (TAN x) (c-tan x))
  474.  
  475. (define-c-external (c-asin double) double "asin")
  476.  
  477. (define (ASIN x) (c-asin x))
  478.  
  479. (define-c-external (c-acos double) double "acos")
  480.  
  481. (define (ACOS x) (c-acos x))
  482.  
  483. (define-c-external (c-atan double) double "atan")
  484.  
  485. (define-c-external (c-atan2 double double) double "atan2")
  486.  
  487. (define (ATAN x . y) (if y (c-atan2 x (car y)) (c-atan x)))
  488.  
  489. (define-c-external (c-sqrt double) double "sqrt")
  490.  
  491. (define (SQRT x)
  492.     (if (negative? x)
  493.     (error 'SQRT "Argument must be a non-negative NUMBER: ~s" x))
  494.     (let ((iresult (c-sqrt x)))
  495.      (if (fixed? x)
  496.          (let ((eresult (float->fixed (round iresult))))
  497.           (if (eq? (* eresult eresult) x)
  498.               eresult
  499.               iresult))
  500.          iresult)))
  501.  
  502. (define-c-external (c-pow double double) double "pow")
  503.  
  504. (define (EXPT x y)
  505.     (if (and (= x 0.0) (= y 0.0))
  506.     1.0
  507.     (let ((iresult (c-pow x y)))
  508.          (if (and (fixed? x) (fixed? y) (<= (abs iresult) #x1fffffff))
  509.          (float->fixed (round iresult))
  510.          iresult))))
  511.  
  512. (define-c-external (c-sprintf-1d pointer pointer double) pointer "sprintf")
  513.  
  514. (define (EXACT->INEXACT x)
  515.     (cond ((fixed? x) (fixed->float x))
  516.       ((float? x) x)
  517.       (else (error 'EXACT->INEXACT "Argument is not a NUMBER: ~s" x))))
  518.  
  519. (define (INEXACT->EXACT x)
  520.     (cond ((fixed? x) x)
  521.       ((float? x) (float->fixed x))
  522.       (else (error 'INEXACT->EXACT "Argument is not a NUMBER: ~s" x))))
  523.  
  524. (define (NUMBER->STRING number . form)
  525.     (if (not (number? number))
  526.     (error 'NUMBER->STRING "Argument is not a NUMBER: ~s" number))
  527.     (set! form (if form (car form) 10))
  528.     (cond ((equal? form '(int))
  529.        ; (int)  =>  [-]dddddddd
  530.        (let ((buffer (make-string 100))
  531.          (f (if (float? number) number (fixed->float number))))
  532.         (c-sprintf-1d buffer "%.0f" f)
  533.         (c-string->string buffer)))
  534.       ((and (pair? form) (= (length form) 2) (eq? (car form) 'fix)
  535.         (fixed? (cadr form)) (>= (cadr form) 0))
  536.        ; (fix n)  =>  [-]dddddddd.  
  537.        (let ((buffer (make-string 100))
  538.          (f (if (float? number) number (fixed->float number))))
  539.         (c-sprintf-1d buffer (format "%.~sf" (cadr form)) f)
  540.         (c-string->string buffer)))
  541.       ((and (pair? form) (= (length form) 2) (eq? (car form) 'sci)
  542.         (fixed? (cadr form)) (>= (cadr form) 0))
  543.        ; (sci n)  =>  [-]d.ddde+dd
  544.        (let ((buffer (make-string 100))
  545.          (f (if (float? number) number (fixed->float number))))
  546.         (c-sprintf-1d buffer (format "%.~se" (- (cadr form) 1)) f)
  547.         (c-string->string buffer)))
  548.       ((= form 2)
  549.        ; 2 => binary integer
  550.        (integer->string number 2 "#b"))
  551.       ((= form 8)
  552.        ; 8 => octal integer
  553.        (integer->string number 8 "#o"))
  554.       ((= form 10)
  555.        ; 10 => any number
  556.        (format "~s" number))
  557.       ((= form 16)
  558.        (integer->string number 16 "#x"))
  559.       (else (error 'NUMBER->STRING
  560.                "Argument is not a RADIX or FORMAT DESCRIPTOR: ~s"
  561.                form))))
  562.  
  563. (define (INTEGER->STRING number base prefix)
  564.     (if (< number 0)
  565.     (integer->string (abs number) base (string-append "-" prefix))
  566.     (string-append
  567.         prefix
  568.         (list->string
  569.         (reverse (let loop ((q (quotient number base))
  570.                     (r (remainder number base)))
  571.                   (let ((digit (string-ref "0123456789abcdef"
  572.                            (inexact->exact r))))
  573.                    (if (= 0 q)
  574.                        (list digit)
  575.                        (cons digit
  576.                          (loop (quotient q base)
  577.                            (remainder q base)))))))))))
  578.  
  579. (define (STRING->NUMBER string . radix)
  580.     (let ((radix (if radix
  581.              (case (car radix)
  582.                ((2) "#b")
  583.                ((8) "#o")
  584.                ((10) "")
  585.                ((16) "#x")
  586.                (else (error 'STRING->NUMBER
  587.                     "Argument is not a RADIX: ~s"
  588.                  (car radix))))
  589.              ""))
  590.       (chars (string->list string)))
  591.      (let loop ((sign "") (chars chars))
  592.           (if chars
  593.           (case (car chars)
  594.             ((#\- #\+) (loop (make-string 1 (car chars))
  595.                      (cdr chars)))
  596.             ((#\#) (try-to-read string))
  597.             (else (try-to-read (string-append sign radix
  598.                            (list->string chars)))))))))
  599.  
  600. (define (TRY-TO-READ string)
  601.     (call-with-current-continuation
  602.     (lambda (return)
  603.         (let ((restore-error-handler *error-handler*))
  604.              (set! *error-handler*
  605.                (lambda x
  606.                    (set! *error-handler* restore-error-handler)
  607.                    (return #f)))
  608.              (let* ((port (open-input-string string))
  609.                 (number (read port))
  610.                 (eof (read port)))
  611.                (set! *error-handler* restore-error-handler)
  612.                (if (and (number? number) (eof-object? eof))
  613.                    number
  614.                    #f))))))
  615.  
  616.              
  617.